home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / stk-3.002 / stk-3 / STk-3.1 / Demos / browse.stklos < prev    next >
Encoding:
Text File  |  1996-02-22  |  1.3 KB  |  49 lines
  1. #!/bin/sh
  2. :;exec /usr/local/bin/stk -f "$0" "$@"
  3. ;;;;
  4. ;;;; A simple STk browser 
  5. ;;;;
  6. ;;;; This script generates a directory browser, which lists the working
  7. ;;;; directory and allows you to open files or subdirectories by
  8. ;;;; double-clicking.
  9. ;;;;
  10. ;;;;
  11. ;;;;           Author: Erick Gallesio [eg@unice.fr]
  12. ;;;;    Creation date:  3-Aug-1993 17:33
  13. ;;;; Last file update: 18-Sep-1995 14:25
  14.  
  15. (require "Tk-classes")
  16. (require "unix")
  17.  
  18. ;;;;
  19. ;;;; Interface
  20. ;;;;
  21. (define lb (make <Scroll-Listbox> :width 30 :height 20 :font 'fixed))
  22. (pack lb :fill "both" :side "top" :expand #t)
  23.  
  24. (define quit (make <Button> :text "Quit" :command '(exit)))
  25. (pack quit :fill "x" :side "bottom" :expand #t)
  26.  
  27. ;;;
  28. ;;; Callback
  29. ;;;
  30. (define (fill-listbox lb dir)
  31.   (chdir dir)
  32.   (delete lb 0 'end)
  33.   (apply insert lb 0 (sort (glob "*" ".*") string<?)))
  34.  
  35. (define (browse)
  36.   (catch 
  37.     (let ((file  (string-append (getcwd) "/" (selection 'get))))
  38.       (cond
  39.         ((file-is-directory? file) (fill-listbox lb file))
  40.     ((file-is-readable? file)  (system (string-append "xedit " file "&")))
  41.     (else               (error "Bad directory or file ~S" file))))))
  42.  
  43.  
  44. ;; Fill the listbox with a list of all the files (in the given directory or ".")
  45. (fill-listbox lb (if (> *argc* 0) (car *argv*) (getcwd)))
  46.  
  47. ;; Set binding for "Double-click" on the listbox
  48. (bind (listbox-of lb) "<Double-Button-1>" browse)
  49.